Hottest 6/Hottest 6 (1996)(PDSoft)[!].iso/software/programming/pascal/hspascal_baseunit.lha/New/Base.PAS

Pascal/Delphi Source File | 1993-03-06 | 6.5 KB | 243 lines

unit Base;

interface

{ *    This unit provides a simple cleans-up-after-itself interface to the
    Graphics and Intuition libraries.  USEing this unit will automatically
    open the Intuition and Graphics libraries, which will be closed when
    your program ends.

    Also provided are two functions to open simple screens and windows.
    These will also be closed when your program ends, regardless.
}

uses
    Exec, Intuition, Graphics;
var
    okBase    : boolean; { TRUE if everything initializes well }

{--- Available functions ---}
function NewScreen(wide,high,deep,view: word;
                    title: string;custom: boolean): pScreen;

function NewWindow(left,top,wide,high: word;
                    f_idcmp,f_settings: longint;
                    wmin,hmin,wmax,hmax: word;
                    wtitle: string;wscreen: pScreen): pWindow;

implementation

const
    BASE_SCREEN = 1;    { Screen stored in list ID }
    BASE_WINDOW = 2;    { Window stored in list ID }
    MAX_BASE_LIST = 20;    { Max. number of screens+windows that
                            would be automatically taken care of }
type
    base_list = record { Record of all opened screens and windows }
        case kind : byte of
            BASE_SCREEN : (pscr : pScreen);
            BASE_WINDOW : (pwin : pWindow)
    end;
var
    ExitSave    : pointer;    { Temporary storage for the exit procedure }
    BaseList    : array[1..MAX_BASE_LIST] of base_list;    { Auto. list }
    topBaseList    : byte;        { How many items in the auto. list }
{----------------------------------------------------------}
procedure CloseBaseList;

{ *    Closes the last screen or window that was opened }

var
    test    : boolean;
begin
    if topBaseList>0 then    { Any opened with NewWindow or NewScreen? }
    begin
        with BaseList[topBaseList] do    { If so, close the last one }
            case kind of
                BASE_WINDOW :
                    CloseWindow(pwin);
                BASE_SCREEN :
                    test := CloseScreen(pscr)
            end;
        dec(topBaseList)    { Decrease the total number of them }
    end
end;
{----------------------------------------------------------}
{$F+}
procedure CloseBase;

{ * This is put in the list of procedures to go through when
    the program exits.  It closes all screens and windows
    opened with NewWindow or NewScreen, and closes the graphics
    and intuition libraries as well
}

begin
    ExitProc := ExitSave;    { Restore exit pointer to original }
    while topBaseList>0 do    { Close all New.. Windows and Screens }
        CloseBaseList;
    if GfxBase<>nil then    { Close graphics library if opened }
        CloseLibrary(pLibrary(GfxBase));
    if IntuitionBase<>nil then    { Close intuition library if opened }
        CloseLibrary(pLibrary(IntuitionBase))
end;
{----------------------------------------------------------}
function NewScreen(wide,high,deep,view: word;
                    title: string;custom: boolean): pScreen;

{ * A quick function to open a screen of dimensions WIDExHIGH,
    with DEEP number of planes.
    VIEW is the viewmodes (HIRES, LACE, etc.)
    TITLE is the title for the screen bar.
    CUSTOM is TRUE for a custom screen, FALSE for a workbench-
        type of screen.
    Returns a pointer to the screen that was opened, or NIL
        if the operation was not successful
}

var
    new_scr    : tNewScreen;
    act_scr : pScreen;
begin
    if topBaseList>=MAX_BASE_LIST then
    begin
        NewScreen := nil;
        exit
    end;
    with new_scr do
    begin
        LeftEdge := 0;
        TopEdge := 0;
        Width := wide;
        Height := high;
        Depth := deep;
        DetailPen := 0;
        BlockPen := 1;
        ViewModes := view;
        if custom then
            Type_ := CUSTOMSCREEN
        else
            Type_ := WBENCHSCREEN;
        Font := nil;
        if title='' then
            DefaultTitle := nil
        else
        begin
            title := title+#0;    { Make it a zero-terminated string }
            DefaultTitle := @title[1]
        end;
        Gadgets := nil;
        CustomBitMap := nil
    end;
    act_scr := OpenScreen(@new_scr);
    if act_scr<>nil then    { Did it open okay? }
    begin
        inc(topBaseList);    { Add it to the auto. list }
        with BaseList[topBaseList] do
        begin
            kind := BASE_SCREEN;
            pscr := act_scr
        end;
        NewScreen := act_scr
    end
    else
        NewScreen := nil
end;
{----------------------------------------------------------}
function NewWindow(left,top,wide,high: word;
                    f_idcmp,f_settings: longint;
                    wmin,hmin,wmax,hmax: word;
                    wtitle: string;wscreen: pScreen): pWindow;

{ *    A quick function to open a window, upper left at LEFT,TOP,
    with dimensions WIDExHIGH.
    F_IDCMP are the IDCMP flags to look for (CLOSEWINDOW_,
        VANILLAKEY, etc.)
    F_SETTINGS are the display flags to set (WINDOWCLOSE,
        WINDOWDRAG, etc.)
    WMIN,HMIN are the minimum dimensions of the window to allow.*
    WMAX,HMAX are the maximum dimensions of the window to allow.*
    (*Set all to zero if the window is not resizeable, otherwise
      the window will be set to be resizeable)
    WTITLE is the title of the window.
    WSCREEN is a pointer to the screen to put it on, NIL for the
        Workbench screen.
    Returns a pointer to the opened window, or NIL if the
        operation was not successful
}

var
    new_win        : tNewWindow;
    act_win        : pWindow;
begin
    if topBaseList>=MAX_BASE_LIST then { Too many already? }
    begin
        NewWindow := nil;
        exit
    end;
    with new_win do
    begin
        LeftEdge := left;
        TopEdge := top;
        Width := wide;
        Height := high;
        DetailPen := -1;
        BlockPen := -1;
        IDCMPFlags := f_idcmp;
        Flags := f_settings;
        FirstGadget := nil;
        CheckMark := nil;
        if wtitle='' then
            Title := nil
        else
        begin
            wtitle := wtitle+#0;    { Make a null-terminated title }
            Title := @wtitle[1]
        end;
        Screen := wscreen;
        BitMap := nil;
        MinWidth := wmin;
        MinHeight := hmin;
        MaxWidth := wmax;
        MaxHeight := hmax;
        if wmin or hmin or wmax or hmax>0 then    { Minimums and maximums? }
            Flags := Flags or WINDOWSIZING;        { Must be resizeable }
        if Screen=nil then
            Type_ := WBENCHSCREEN
        else
            Type_ := CUSTOMSCREEN
    end;
    act_win := OpenWindow(@new_win);
    if act_win<>nil then    { Opened okay? }
    begin
        inc(topBaseList);    { Add it to the list }
        with BaseList[topBaseList] do
        begin
            kind := BASE_WINDOW;
            pwin := act_win
        end;
        NewWindow := act_win
    end
    else
        NewWindow := nil
end;
{----------------------------------------------------------}
{ Initialization section diverts the exit routine to CloseBase
  upon exit and initializes the libraries that will be used
}

begin
    okBase := FALSE;    { Not everything is okay yet }
    IntuitionBase := nil;    { Hasn't been opened yet, set to NIL }
    GfxBase := nil;            { Same here }
    topBaseList := 0;        { Nothing in the auto. list }
    ExitSave := ExitProc;    { Store the current exit procedure }
    ExitProc := @CloseBase; { Add CloseBase to exit chain }
    IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',0));
    if IntuitionBase<>nil then
    begin
        GfxBase := pGfxBase(OpenLibrary('graphics.library',0));
        if GfxBase<>nil then
            okBase := TRUE
    end
end.